home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / gnu / dejagnu.lha / dejagnu-1.0.1 / tcl / tclProc.c < prev    next >
C/C++ Source or Header  |  1993-02-13  |  15KB  |  564 lines
  1. /* 
  2.  * tclProc.c --
  3.  *
  4.  *    This file contains routines that implement Tcl procedures,
  5.  *    including the "proc" and "uplevel" commands.
  6.  *
  7.  * Copyright 1987-1991 Regents of the University of California
  8.  * Permission to use, copy, modify, and distribute this
  9.  * software and its documentation for any purpose and without
  10.  * fee is hereby granted, provided that the above copyright
  11.  * notice appear in all copies.  The University of California
  12.  * makes no representations about the suitability of this
  13.  * software for any purpose.  It is provided "as is" without
  14.  * express or implied warranty.
  15.  */
  16.  
  17. #include "tclInt.h"
  18.  
  19. /*
  20.  * Forward references to procedures defined later in this file:
  21.  */
  22.  
  23. static  int    InterpProc _ANSI_ARGS_((ClientData clientData,
  24.             Tcl_Interp *interp, int argc, char **argv));
  25. static  void    ProcDeleteProc _ANSI_ARGS_((ClientData clientData));
  26.  
  27. /*
  28.  *----------------------------------------------------------------------
  29.  *
  30.  * Tcl_ProcCmd --
  31.  *
  32.  *    This procedure is invoked to process the "proc" Tcl command.
  33.  *    See the user documentation for details on what it does.
  34.  *
  35.  * Results:
  36.  *    A standard Tcl result value.
  37.  *
  38.  * Side effects:
  39.  *    A new procedure gets created.
  40.  *
  41.  *----------------------------------------------------------------------
  42.  */
  43.  
  44.     /* ARGSUSED */
  45. int
  46. Tcl_ProcCmd(dummy, interp, argc, argv)
  47.     ClientData dummy;            /* Not used. */
  48.     Tcl_Interp *interp;            /* Current interpreter. */
  49.     int argc;                /* Number of arguments. */
  50.     char **argv;            /* Argument strings. */
  51. {
  52.     register Interp *iPtr = (Interp *) interp;
  53.     register Proc *procPtr;
  54.     int result, argCount, i;
  55.     char **argArray = NULL;
  56.     Arg *lastArgPtr;
  57.     register Arg *argPtr = NULL;    /* Initialization not needed, but
  58.                      * prevents compiler warning. */
  59.  
  60.     if (argc != 4) {
  61.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  62.         " name args body\"", (char *) NULL);
  63.     return TCL_ERROR;
  64.     }
  65.  
  66.     procPtr = (Proc *) ckalloc(sizeof(Proc));
  67.     procPtr->iPtr = iPtr;
  68.     procPtr->command = (char *) ckalloc((unsigned) strlen(argv[3]) + 1);
  69.     strcpy(procPtr->command, argv[3]);
  70.     procPtr->argPtr = NULL;
  71.  
  72.     /*
  73.      * Break up the argument list into argument specifiers, then process
  74.      * each argument specifier.
  75.      */
  76.  
  77.     result = Tcl_SplitList(interp, argv[2], &argCount, &argArray);
  78.     if (result != TCL_OK) {
  79.     goto procError;
  80.     }
  81.     lastArgPtr = NULL;
  82.     for (i = 0; i < argCount; i++) {
  83.     int fieldCount, nameLength, valueLength;
  84.     char **fieldValues;
  85.  
  86.     /*
  87.      * Now divide the specifier up into name and default.
  88.      */
  89.  
  90.     result = Tcl_SplitList(interp, argArray[i], &fieldCount,
  91.         &fieldValues);
  92.     if (result != TCL_OK) {
  93.         goto procError;
  94.     }
  95.     if (fieldCount > 2) {
  96.         ckfree((char *) fieldValues);
  97.         Tcl_AppendResult(interp,
  98.             "too many fields in argument specifier \"",
  99.             argArray[i], "\"", (char *) NULL);
  100.         result = TCL_ERROR;
  101.         goto procError;
  102.     }
  103.     if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
  104.         ckfree((char *) fieldValues);
  105.         Tcl_AppendResult(interp, "procedure \"", argv[1],
  106.             "\" has argument with no name", (char *) NULL);
  107.         result = TCL_ERROR;
  108.         goto procError;
  109.     }
  110.     nameLength = strlen(fieldValues[0]) + 1;
  111.     if (fieldCount == 2) {
  112.         valueLength = strlen(fieldValues[1]) + 1;
  113.     } else {
  114.         valueLength = 0;
  115.     }
  116.     argPtr = (Arg *) ckalloc((unsigned)
  117.         (sizeof(Arg) - sizeof(argPtr->name) + nameLength
  118.         + valueLength));
  119.     if (lastArgPtr == NULL) {
  120.         procPtr->argPtr = argPtr;
  121.     } else {
  122.         lastArgPtr->nextPtr = argPtr;
  123.     }
  124.     lastArgPtr = argPtr;
  125.     argPtr->nextPtr = NULL;
  126.     strcpy(argPtr->name, fieldValues[0]);
  127.     if (fieldCount == 2) {
  128.         argPtr->defValue = argPtr->name + nameLength;
  129.         strcpy(argPtr->defValue, fieldValues[1]);
  130.     } else {
  131.         argPtr->defValue = NULL;
  132.     }
  133.     ckfree((char *) fieldValues);
  134.     }
  135.  
  136.     Tcl_CreateCommand(interp, argv[1], InterpProc, (ClientData) procPtr,
  137.         ProcDeleteProc);
  138.     ckfree((char *) argArray);
  139.     return TCL_OK;
  140.  
  141.     procError:
  142.     ckfree(procPtr->command);
  143.     while (procPtr->argPtr != NULL) {
  144.     argPtr = procPtr->argPtr;
  145.     procPtr->argPtr = argPtr->nextPtr;
  146.     ckfree((char *) argPtr);
  147.     }
  148.     ckfree((char *) procPtr);
  149.     if (argArray != NULL) {
  150.     ckfree((char *) argArray);
  151.     }
  152.     return result;
  153. }
  154.  
  155. /*
  156.  *----------------------------------------------------------------------
  157.  *
  158.  * TclGetFrame --
  159.  *
  160.  *    Given a description of a procedure frame, such as the first
  161.  *    argument to an "uplevel" or "upvar" command, locate the
  162.  *    call frame for the appropriate level of procedure.
  163.  *
  164.  * Results:
  165.  *    The return value is -1 if an error occurred in finding the
  166.  *    frame (in this case an error message is left in interp->result).
  167.  *    1 is returned if string was either a number or a number preceded
  168.  *    by "#" and it specified a valid frame.  0 is returned if string
  169.  *    isn't one of the two things above (in this case, the lookup
  170.  *    acts as if string were "1").  The variable pointed to by
  171.  *    framePtrPtr is filled in with the address of the desired frame
  172.  *    (unless an error occurs, in which case it isn't modified).
  173.  *
  174.  * Side effects:
  175.  *    None.
  176.  *
  177.  *----------------------------------------------------------------------
  178.  */
  179.  
  180. int
  181. TclGetFrame(interp, string, framePtrPtr)
  182.     Tcl_Interp *interp;        /* Interpreter in which to find frame. */
  183.     char *string;        /* String describing frame. */
  184.     CallFrame **framePtrPtr;    /* Store pointer to frame here (or NULL
  185.                  * if global frame indicated). */
  186. {
  187.     register Interp *iPtr = (Interp *) interp;
  188.     int level, result;
  189.     CallFrame *framePtr;
  190.  
  191.     if (iPtr->varFramePtr == NULL) {
  192.     iPtr->result = "already at top level";
  193.     return -1;
  194.     }
  195.  
  196.     /*
  197.      * Parse string to figure out which level number to go to.
  198.      */
  199.  
  200.     result = 1;
  201.     if (*string == '#') {
  202.     if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) {
  203.         return -1;
  204.     }
  205.     if (level < 0) {
  206.         levelError:
  207.         Tcl_AppendResult(interp, "bad level \"", string, "\"",
  208.             (char *) NULL);
  209.         return -1;
  210.     }
  211.     } else if (isdigit(*string)) {
  212.     if (Tcl_GetInt(interp, string, &level) != TCL_OK) {
  213.         return -1;
  214.     }
  215.     level = iPtr->varFramePtr->level - level;
  216.     } else {
  217.     level = iPtr->varFramePtr->level - 1;
  218.     result = 0;
  219.     }
  220.  
  221.     /*
  222.      * Figure out which frame to use, and modify the interpreter so
  223.      * its variables come from that frame.
  224.      */
  225.  
  226.     if (level == 0) {
  227.     framePtr = NULL;
  228.     } else {
  229.     for (framePtr = iPtr->varFramePtr; framePtr != NULL;
  230.         framePtr = framePtr->callerVarPtr) {
  231.         if (framePtr->level == level) {
  232.         break;
  233.         }
  234.     }
  235.     if (framePtr == NULL) {
  236.         goto levelError;
  237.     }
  238.     }
  239.     *framePtrPtr = framePtr;
  240.     return result;
  241. }
  242.  
  243. /*
  244.  *----------------------------------------------------------------------
  245.  *
  246.  * Tcl_UplevelCmd --
  247.  *
  248.  *    This procedure is invoked to process the "uplevel" Tcl command.
  249.  *    See the user documentation for details on what it does.
  250.  *
  251.  * Results:
  252.  *    A standard Tcl result value.
  253.  *
  254.  * Side effects:
  255.  *    See the user documentation.
  256.  *
  257.  *----------------------------------------------------------------------
  258.  */
  259.  
  260.     /* ARGSUSED */
  261. int
  262. Tcl_UplevelCmd(dummy, interp, argc, argv)
  263.     ClientData dummy;            /* Not used. */
  264.     Tcl_Interp *interp;            /* Current interpreter. */
  265.     int argc;                /* Number of arguments. */
  266.     char **argv;            /* Argument strings. */
  267. {
  268.     register Interp *iPtr = (Interp *) interp;
  269.     int result;
  270.     CallFrame *savedVarFramePtr, *framePtr;
  271.  
  272.     if (argc < 2) {
  273.     uplevelSyntax:
  274.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  275.         " ?level? command ?arg ...?\"", (char *) NULL);
  276.     return TCL_ERROR;
  277.     }
  278.  
  279.     /*
  280.      * Find the level to use for executing the command.
  281.      */
  282.  
  283.     result = TclGetFrame(interp, argv[1], &framePtr);
  284.     if (result == -1) {
  285.     return TCL_ERROR;
  286.     }
  287.     argc -= (result+1);
  288.     if (argc == 0) {
  289.     goto uplevelSyntax;
  290.     }
  291.     argv += (result+1);
  292.  
  293.     /*
  294.      * Modify the interpreter state to execute in the given frame.
  295.      */
  296.  
  297.     savedVarFramePtr = iPtr->varFramePtr;
  298.     iPtr->varFramePtr = framePtr;
  299.  
  300.     /*
  301.      * Execute the residual arguments as a command.
  302.      */
  303.  
  304.     if (argc == 1) {
  305.     result = Tcl_Eval(interp, argv[0], 0, (char **) NULL);
  306.     } else {
  307.     char *cmd;
  308.  
  309.     cmd = Tcl_Concat(argc, argv);
  310.     result = Tcl_Eval(interp, cmd, 0, (char **) NULL);
  311.     ckfree(cmd);
  312.     }
  313.     if (result == TCL_ERROR) {
  314.     char msg[60];
  315.     sprintf(msg, "\n    (\"uplevel\" body line %d)", interp->errorLine);
  316.     Tcl_AddErrorInfo(interp, msg);
  317.     }
  318.  
  319.     /*
  320.      * Restore the variable frame, and return.
  321.      */
  322.  
  323.     iPtr->varFramePtr = savedVarFramePtr;
  324.     return result;
  325. }
  326.  
  327. /*
  328.  *----------------------------------------------------------------------
  329.  *
  330.  * TclFindProc --
  331.  *
  332.  *    Given the name of a procedure, return a pointer to the
  333.  *    record describing the procedure.
  334.  *
  335.  * Results:
  336.  *    NULL is returned if the name doesn't correspond to any
  337.  *    procedure.  Otherwise the return value is a pointer to
  338.  *    the procedure's record.
  339.  *
  340.  * Side effects:
  341.  *    None.
  342.  *
  343.  *----------------------------------------------------------------------
  344.  */
  345.  
  346. Proc *
  347. TclFindProc(iPtr, procName)
  348.     Interp *iPtr;        /* Interpreter in which to look. */
  349.     char *procName;        /* Name of desired procedure. */
  350. {
  351.     Tcl_HashEntry *hPtr;
  352.     Command *cmdPtr;
  353.  
  354.     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, procName);
  355.     if (hPtr == NULL) {
  356.     return NULL;
  357.     }
  358.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  359.     if (cmdPtr->proc != InterpProc) {
  360.     return NULL;
  361.     }
  362.     return (Proc *) cmdPtr->clientData;
  363. }
  364.  
  365. /*
  366.  *----------------------------------------------------------------------
  367.  *
  368.  * TclIsProc --
  369.  *
  370.  *    Tells whether a command is a Tcl procedure or not.
  371.  *
  372.  * Results:
  373.  *    If the given command is actuall a Tcl procedure, the
  374.  *    return value is the address of the record describing
  375.  *    the procedure.  Otherwise the return value is 0.
  376.  *
  377.  * Side effects:
  378.  *    None.
  379.  *
  380.  *----------------------------------------------------------------------
  381.  */
  382.  
  383. Proc *
  384. TclIsProc(cmdPtr)
  385.     Command *cmdPtr;        /* Command to test. */
  386. {
  387.     if (cmdPtr->proc == InterpProc) {
  388.     return (Proc *) cmdPtr->clientData;
  389.     }
  390.     return (Proc *) 0;
  391. }
  392.  
  393. /*
  394.  *----------------------------------------------------------------------
  395.  *
  396.  * InterpProc --
  397.  *
  398.  *    When a Tcl procedure gets invoked, this routine gets invoked
  399.  *    to interpret the procedure.
  400.  *
  401.  * Results:
  402.  *    A standard Tcl result value, usually TCL_OK.
  403.  *
  404.  * Side effects:
  405.  *    Depends on the commands in the procedure.
  406.  *
  407.  *----------------------------------------------------------------------
  408.  */
  409.  
  410. static int
  411. InterpProc(clientData, interp, argc, argv)
  412.     ClientData clientData;    /* Record describing procedure to be
  413.                  * interpreted. */
  414.     Tcl_Interp *interp;        /* Interpreter in which procedure was
  415.                  * invoked. */
  416.     int argc;            /* Count of number of arguments to this
  417.                  * procedure. */
  418.     char **argv;        /* Argument values. */
  419. {
  420.     register Proc *procPtr = (Proc *) clientData;
  421.     register Arg *argPtr;
  422.     register Interp *iPtr = (Interp *) interp;
  423.     char **args;
  424.     CallFrame frame;
  425.     char *value, *end;
  426.     int result;
  427.  
  428.     /*
  429.      * Set up a call frame for the new procedure invocation.
  430.      */
  431.  
  432.     iPtr = procPtr->iPtr;
  433.     Tcl_InitHashTable(&frame.varTable, TCL_STRING_KEYS);
  434.     if (iPtr->varFramePtr != NULL) {
  435.     frame.level = iPtr->varFramePtr->level + 1;
  436.     } else {
  437.     frame.level = 1;
  438.     }
  439.     frame.argc = argc;
  440.     frame.argv = argv;
  441.     frame.callerPtr = iPtr->framePtr;
  442.     frame.callerVarPtr = iPtr->varFramePtr;
  443.     iPtr->framePtr = &frame;
  444.     iPtr->varFramePtr = &frame;
  445.  
  446.     /*
  447.      * Match the actual arguments against the procedure's formal
  448.      * parameters to compute local variables.
  449.      */
  450.  
  451.     for (argPtr = procPtr->argPtr, args = argv+1, argc -= 1;
  452.         argPtr != NULL;
  453.         argPtr = argPtr->nextPtr, args++, argc--) {
  454.  
  455.     /*
  456.      * Handle the special case of the last formal being "args".  When
  457.      * it occurs, assign it a list consisting of all the remaining
  458.      * actual arguments.
  459.      */
  460.  
  461.     if ((argPtr->nextPtr == NULL)
  462.         && (strcmp(argPtr->name, "args") == 0)) {
  463.         if (argc < 0) {
  464.         argc = 0;
  465.         }
  466.         value = Tcl_Merge(argc, args);
  467.         Tcl_SetVar(interp, argPtr->name, value, 0);
  468.         ckfree(value);
  469.         argc = 0;
  470.         break;
  471.     } else if (argc > 0) {
  472.         value = *args;
  473.     } else if (argPtr->defValue != NULL) {
  474.         value = argPtr->defValue;
  475.     } else {
  476.         Tcl_AppendResult(interp, "no value given for parameter \"",
  477.             argPtr->name, "\" to \"", argv[0], "\"",
  478.             (char *) NULL);
  479.         result = TCL_ERROR;
  480.         goto procDone;
  481.     }
  482.     Tcl_SetVar(interp, argPtr->name, value, 0);
  483.     }
  484.     if (argc > 0) {
  485.     Tcl_AppendResult(interp, "called \"", argv[0],
  486.         "\" with too many arguments", (char *) NULL);
  487.     result = TCL_ERROR;
  488.     goto procDone;
  489.     }
  490.  
  491.     /*
  492.      * Invoke the commands in the procedure's body.
  493.      */
  494.  
  495.     result = Tcl_Eval(interp, procPtr->command, 0, &end);
  496.     if (result == TCL_RETURN) {
  497.     result = TCL_OK;
  498.     } else if (result == TCL_ERROR) {
  499.     char msg[100];
  500.  
  501.     /*
  502.      * Record information telling where the error occurred.
  503.      */
  504.  
  505.     sprintf(msg, "\n    (procedure \"%.50s\" line %d)", argv[0],
  506.         iPtr->errorLine);
  507.     Tcl_AddErrorInfo(interp, msg);
  508.     } else if (result == TCL_BREAK) {
  509.     iPtr->result = "invoked \"break\" outside of a loop";
  510.     result = TCL_ERROR;
  511.     } else if (result == TCL_CONTINUE) {
  512.     iPtr->result = "invoked \"continue\" outside of a loop";
  513.     result = TCL_ERROR;
  514.     }
  515.  
  516.     /*
  517.      * Delete the call frame for this procedure invocation (it's
  518.      * important to remove the call frame from the interpreter
  519.      * before deleting it, so that traces invoked during the
  520.      * deletion don't see the partially-deleted frame).
  521.      */
  522.  
  523.     procDone:
  524.     iPtr->framePtr = frame.callerPtr;
  525.     iPtr->varFramePtr = frame.callerVarPtr;
  526.     TclDeleteVars(iPtr, &frame.varTable);
  527.     return result;
  528. }
  529.  
  530. /*
  531.  *----------------------------------------------------------------------
  532.  *
  533.  * ProcDeleteProc --
  534.  *
  535.  *    This procedure is invoked just before a command procedure is
  536.  *    removed from an interpreter.  Its job is to release all the
  537.  *    resources allocated to the procedure.
  538.  *
  539.  * Results:
  540.  *    None.
  541.  *
  542.  * Side effects:
  543.  *    Memory gets freed.
  544.  *
  545.  *----------------------------------------------------------------------
  546.  */
  547.  
  548. static void
  549. ProcDeleteProc(clientData)
  550.     ClientData clientData;        /* Procedure to be deleted. */
  551. {
  552.     register Proc *procPtr = (Proc *) clientData;
  553.     register Arg *argPtr;
  554.  
  555.     ckfree((char *) procPtr->command);
  556.     for (argPtr = procPtr->argPtr; argPtr != NULL; ) {
  557.     Arg *nextPtr = argPtr->nextPtr;
  558.  
  559.     ckfree((char *) argPtr);
  560.     argPtr = nextPtr;
  561.     }
  562.     ckfree((char *) procPtr);
  563. }
  564.